home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / demos / gtmenu.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-01  |  4.6 KB  |  167 lines
  1. Program GadtoolsMenu;
  2.  
  3. {* gadtoolsmenu.p
  4. ** Example showing the basic usage of the menu system with a window.
  5. ** Menu layout is done with GadTools, as is recommended for applications.
  6. **
  7. *}
  8.  
  9. {
  10.    Changed to use TAGS and pas2c.
  11.    1 Nov 1998.
  12.  
  13.    nils.sjoholm@mailbox.swipnet.se
  14. }
  15.  
  16. uses Exec, Intuition, Utility, GadTools, vartags;
  17.  
  18.  
  19.  
  20. const
  21.  
  22.     mynewmenu : array[0..15] of tNewMenu = (
  23.     (nm_Type: NM_TITLE; nm_Label:'Project';   nm_CommKey: NIL;  nm_Flags:0; 
  24. nm_MutualExclude:0; nm_UserData:NIL),
  25.     (nm_Type: NM_ITEM;  nm_Label:'Open...';   nm_CommKey:'O';   nm_Flags:0; 
  26. nm_MutualExclude:0; nm_UserData:NIL),
  27.     (nm_Type: NM_ITEM;  nm_Label:'Save';      nm_CommKey:'S';   nm_Flags:0; 
  28. nm_MutualExclude:0; nm_UserData:NIL),
  29.     (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; 
  30. nm_MutualExclude:0; nm_UserData:NIL),
  31.  
  32.     (nm_Type: NM_ITEM;  nm_Label:'Print';     nm_CommKey: NIL;  nm_Flags:0; 
  33. nm_MutualExclude:0; nm_UserData:NIL),
  34.     (nm_Type: NM_SUB;   nm_Label:'Draft';     nm_CommKey: NIL;  nm_Flags:0; 
  35. nm_MutualExclude:0; nm_UserData:NIL),
  36.     (nm_Type: NM_SUB;   nm_Label:'NLQ';       nm_CommKey: NIL;  nm_Flags:0; 
  37. nm_MutualExclude:0; nm_UserData:NIL),
  38.     (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; 
  39. nm_MutualExclude:0; nm_UserData:NIL),
  40.  
  41.     (nm_Type: NM_ITEM;  nm_Label:'Quit...';   nm_CommKey:'Q';   nm_Flags:0; 
  42. nm_MutualExclude:0; nm_UserData:NIL),
  43.  
  44.     (nm_Type: NM_TITLE; nm_Label:'Edit';      nm_CommKey: NIL;  nm_Flags:0; 
  45. nm_MutualExclude:0; nm_UserData:NIL),
  46.     (nm_Type: NM_ITEM;  nm_Label:'Cut';       nm_CommKey:'X';   nm_Flags:0; 
  47. nm_MutualExclude:0; nm_UserData:NIL),
  48.     (nm_Type: NM_ITEM;  nm_Label:'Copy';      nm_CommKey:'C';   nm_Flags:0; 
  49. nm_MutualExclude:0; nm_UserData:NIL),
  50.     (nm_Type: NM_ITEM;  nm_Label:'Paste';     nm_CommKey:'V';   nm_Flags:0; 
  51. nm_MutualExclude:0; nm_UserData:NIL),
  52.     (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; 
  53. nm_MutualExclude:0; nm_UserData:NIL),
  54.  
  55.     (nm_Type: NM_ITEM;  nm_Label:'Undo';      nm_CommKey:'Z';   nm_Flags:0; 
  56. nm_MutualExclude:0; nm_UserData:NIL),
  57.  
  58.     (nm_Type:   NM_END; nm_Label:NIL;         nm_CommKey:NIL;   nm_Flags:0; 
  59. nm_MutualExclude:0; nm_UserData:NIL));
  60.  
  61. var
  62.    win : pWindow;
  63.    myVisualInfo : Pointer;
  64.    menuStrip : pMenu;
  65.    msg  : pMessage;
  66.    done : boolean;
  67.  
  68. Procedure Die;
  69. begin
  70.     if assigned(MenuStrip) then begin
  71.        ClearMenuStrip(win);
  72.        FreeMenus(MenuStrip);
  73.     end;
  74.     if assigned(myVisualInfo) then FreeVisualInfo(myVisualInfo);
  75.     if assigned(win) then CloseWindow(win);
  76.     Halt(0);
  77. end;
  78.  
  79.  
  80.  
  81.  
  82. {*
  83. ** Watch the menus and wait for the user to select the close gadget
  84. ** or quit from the menus.
  85. *}
  86. PROCEDURE ProcessIDCMP;
  87. VAR
  88.     IMessage    : tIntuiMessage;
  89.     IPtr    : pIntuiMessage;
  90.  
  91.     Procedure ProcessMenu;
  92.     var
  93.     MenuNumber  : Word;
  94.     ItemNumber  : Word;
  95.     SubItemNumber   : Word;
  96.  
  97.     begin
  98.     if IMessage.Code = MENUNULL then
  99.         Exit;
  100.  
  101.     MenuNumber := MenuNum(IMessage.Code);
  102.     ItemNumber := ItemNum(IMessage.Code);
  103.     SubItemNumber := SubNum(IMessage.Code);
  104.  
  105.     if (MenuNumber = 0) and (ItemNumber = 5) then done := true;
  106.     end;
  107.  
  108. begin
  109.     IPtr := pIntuiMessage(Msg);
  110.     IMessage := IPtr^;
  111.     ReplyMsg(Msg);
  112.  
  113.     case IMessage.IClass of
  114.       IDCMP_MENUPICK    : ProcessMenu;
  115.       IDCMP_CLOSEWINDOW : done := True;
  116.     end;
  117. end;
  118.  
  119. {*
  120. ** Open all of the required libraries and set-up the menus.
  121. *}
  122.  
  123. begin
  124.  
  125.     win := OpenWindowTagList(NIL, TAGS(
  126.                              WA_Width,  400,
  127.                              WA_Activate,    ltrue,
  128.                              WA_Height, 100,
  129.                              WA_CloseGadget, ltrue,
  130.                              WA_Title,  Longstr('Menu Test Window'),
  131.                              WA_IDCMP,  IDCMP_CLOSEWINDOW or IDCMP_MENUPICK,
  132.                              TAG_END));
  133.     
  134.     if win = nil then die;
  135.  
  136.     myVisualInfo := GetVisualInfoA(win^.WScreen,nil);
  137.     if myVisualInfo = nil then die;
  138.  
  139.     {
  140.       make the barlabels
  141.     }
  142.     mynewmenu[3].nm_Label := PChar(NM_BARLABEL);
  143.     mynewmenu[7].nm_Label := PChar(NM_BARLABEL);
  144.     mynewmenu[13].nm_Label := PChar(NM_BARLABEL);
  145.  
  146.     if pExecBase(_ExecBase)^.LibNode.Lib_Version >= 39 then begin
  147.         MenuStrip := CreateMenusA(@mynewmenu, TAGS(
  148.                                   GTMN_FrontPen, 1,
  149.                                   TAG_END));
  150.     end else MenuStrip := CreateMenusA(@mynewmenu,NIL);
  151.  
  152.     if menuStrip = nil then die;
  153.  
  154.     if not LayoutMenusA(menuStrip, myVisualInfo,nil) then die;
  155.  
  156.     if not SetMenuStrip(win,menuStrip) then die;
  157.  
  158.     repeat
  159.     Msg := WaitPort(win^.UserPort);
  160.     Msg := GetMsg(win^.UserPort);
  161.        ProcessIDCMP;
  162.     until done;
  163.     die;
  164. end.
  165.  
  166.  
  167.